#light

module CGraph.SchemaGraph.Builder

open CGraph.SchemaGraph
open CGraph.Generic
open CGraph.DirectedGraph
open System.Collections.Generic
open System.Xml.Schema
open System.Text
open System.Xml
open System

/// The builder context maps current datatypes by name
/// to the vertexes that represent them.
type BuilderContext =
    val m_typeDict : IDictionary<string, IDatatypeVertex>
    /// Option values are part of the genius of this language.
    /// In my current project, I there are many bugs where something
    /// is null and someone doesn't expect that.  Options would at least
    /// make such expectations very explicit.
    /// m_parent is used to lookup values up the tree.
    val m_parent : BuilderContext option
    new() = BuilderContext( None )
    new( parent ) = { 
        m_typeDict = (new Dictionary<string,IDatatypeVertex>() :> IDictionary<string,IDatatypeVertex>)
        m_parent = parent
        }
    /// Add the vertex to this mapping.
    member this.AddVertex( vert:IDatatypeVertex ) = this.m_typeDict.Add( vert.Name, vert )
    
    /// Lookup the vertex by name.  If this object has a parent and the local
    /// lookup fails, then lookup using its parent.
    member this.Lookup name =
        let success,value = this.m_typeDict.TryGetValue( name )
        if not ( success ) 
            then 
                match this.m_parent with
                    | Some parent -> parent.Lookup( name )
                    | None -> None
            else
                Some(value)
     
    member this.NoFailLookup name =
        let vtxOpt = this.Lookup name
        match vtxOpt with
            | Some vtx -> vtx
            | None -> raise (new System.InvalidOperationException("Operation was invalid"))

/// Parse context record type.  I didn't want to put this here, but I can't figure out how
/// to forward declare functions without the fsi file, and records created in the
/// fsi file were not referenceable in the fs file.
type ParserContext =
    {    
        Graph : ISchemaGraph
        Context : BuilderContext
        PostProcess : ((unit->unit) List)
    }
            
    
let CreateSimple (graph:ISchemaGraph) (context:BuilderContext) name =
    let retval = graph.Vertexes.CreateSimpleVertex( name )
    context.AddVertex( retval :?> IDatatypeVertex )
    retval
    
let CreateSimpleTypes graph context parent children =
    for name in children do
        let newVert = CreateSimple graph context name
        graph.Edges.Restrict parent (newVert :?> IDatatypeVertex) |> ignore

let CreateSimpleTypeStr graph context name children =
    let matcher vertex = 
        match vertex with
            | Some vtx -> CreateSimpleTypes graph context vtx children
            | None -> raise (new System.InvalidOperationException("Missing datatype"))
    matcher (context.Lookup name)
        
        
let CreateSimpleList graph context name child =
    let matcher (parentOpt:IDatatypeVertex option) = 
        match parentOpt with
            | Some parent -> 
                let vertex = CreateSimple graph context child
                graph.Edges.DeriveList (parent :?> ISimpleDatatypeVertex) vertex |> ignore
            | None -> raise (new System.InvalidOperationException("Missing datatype"))
    matcher (context.Lookup name)
        
/// Build the basic simple types.
/// http://www.w3.org/TR/xmlschema-2/#built-in-datatypes
let BuildBasicTypes (graph:ISchemaGraph) (context:BuilderContext) =
      
    let CreateSimpleTypes = CreateSimpleTypes graph context    
    let CreateSimple = CreateSimple graph context
    let CreateSimpleTypeStr = CreateSimpleTypeStr graph context
    let CreateSimpleList = CreateSimpleList graph context
    
    let anyType = CreateSimple "anyType"
    let anySimpleType = CreateSimple "anySimpleType"
    
    graph.Edges.Restrict (anyType :?> IDatatypeVertex) (anySimpleType :?> IDatatypeVertex) |> ignore
    
    CreateSimpleTypes 
        (anySimpleType :?> IDatatypeVertex)
        [| "duration"; "dateTime"; "time"; "date"; "gYearMonth"
           ; "gYear"; "gMonth"; "gDay"; "gMonthDay"; "string"
           ; "boolean"; "base64Binary"; "hexBinary"; "float"
           ; "double"; "decimal"; "anyURI"; "QName"; "NOTATION" |]
          
    CreateSimpleTypeStr "string" [|"normalizedString" |]
    CreateSimpleTypeStr "normalizedString" [| "token" |]
    CreateSimpleTypeStr "token" [| "language"; "Name"; "NMTOKEN" |]
    CreateSimpleTypeStr "Name" [| "NCName" |]
    CreateSimpleTypeStr "NCName" [| "ID"; "IDREF"; "ENTITY" |]
    CreateSimpleTypeStr "decimal" [| "integer" |]
    CreateSimpleTypeStr "integer" [| "nonPositiveInteger"; "long"; "nonNegativeInteger" |]
    CreateSimpleTypeStr "nonPositiveInteger" [| "negativeInteger" |]
    CreateSimpleTypeStr "long" [| "int" |]
    CreateSimpleTypeStr "nonNegativeInteger" [| "unsignedLong"; "positiveInteger" |]
    CreateSimpleTypeStr "int" [| "short" |]
    CreateSimpleTypeStr "short" [| "byte" |]
    CreateSimpleTypeStr "unsignedLong" [| "unsignedInt" |]
    CreateSimpleTypeStr "unsignedInt" [| "unsignedShort" |]
    CreateSimpleTypeStr "unsignedShort" [| "unsignedByte" |]
    
    CreateSimpleList "NMTOKEN" "NMTOKENS" 
    CreateSimpleList "IDREF" "IDREFS" 
    CreateSimpleList "ENTITY" "ENTITIES" 
    
let ObjsToTyped (objs:XmlSchemaObjectCollection) =
    Seq.map_to_typed (fun( (item:obj) ) -> item :?> XmlSchemaObject ) objs
    
let ProcessAnnotation (elem:XmlSchemaAnnotation option) =
    let IsDocumentation (item:XmlSchemaObject) =
        match item with
            | :? XmlSchemaDocumentation as doc -> Some(doc)
            | _ -> None
            
    let NodesToStr nodes =
        let builder = new StringBuilder()
        for (node:XmlNode) in nodes do
            builder.Append node.Value |> ignore
        builder.ToString()
    
    match elem with
        | None -> None
        | Some elem ->
            let typedItems = ObjsToTyped elem.Items
            let firstDoc = Seq.first IsDocumentation typedItems
            match firstDoc with
                | Some doc -> Some (NodesToStr doc.Markup)
                | None -> None
    

let RefNameAccess (elem:XmlSchemaElement) =
    let refNameType = elem.RefName
    match refNameType with
        | null -> None
        | _ -> Some(refNameType.Name)
    
                
let ProcessSimpleType (pcontext:ParserContext) (simple:XmlSchemaSimpleType) =
    pcontext.Graph.Vertexes.CreateSimpleVertex("")
        
let ProcessLocalAttributes (pcontext:ParserContext) vertex atts =
    for elem in (ObjsToTyped atts ) do
        match elem with
            | :? XmlSchemaAttribute as att ->
                if att.RefName <> null then raise (new System.InvalidOperationException("Referenced attributes not supported"))
                let defValue = if att.DefaultValue = null then None else Some att.DefaultValue
                let fixValue = if att.FixedValue = null then None else Some att.FixedValue
                let attVertex = pcontext.Graph.Vertexes.CreateLocalAttributeVertex att.Name defValue fixValue
                pcontext.Graph.Edges.AddLocalAttribute vertex attVertex |> ignore
                if att.SchemaTypeName = null 
                    then //Local definition
                        let simple = att.SchemaType
                        let dtypeVtx = ProcessSimpleType pcontext simple
                        pcontext.Graph.Edges.Reference (attVertex :?> IVertex) (dtypeVtx :?> IDatatypeVertex) |> ignore
                    else
                        pcontext.PostProcess.Add( (fun() ->
                            let vtx = pcontext.Context.NoFailLookup att.SchemaTypeName.Name
                            pcontext.Graph.Edges.Reference (attVertex :?> IVertex) vtx |> ignore ))
            | _ -> raise (new InvalidOperationException "Object in attribute list not an attribute"  )
                    
                
        
let CreateComplexVertex (graph:ISchemaGraph) (context:BuilderContext) name =
    let retval = graph.Vertexes.CreateComplexVertex name
    context.AddVertex( retval :?> IDatatypeVertex )
    retval
    
let ProcessAnnotationType (graph:ISchemaGraph) vert (ann:obj) =
    match ann with
        | :? XmlSchemaAnnotated as ann -> 
                                    let docOpt = ProcessAnnotation (Some ann.Annotation)
                                    match docOpt with
                                        | Some doc -> graph.Edges.Document vert doc |> ignore
                                        | None -> ()
        | _ -> ()
        
    
/// Something with a content model is basically derived from something else.
let rec ProcessComplexElemContentModel (pcontext:ParserContext) (content:XmlSchemaContentModel) (vert:IComplexDatatypeVertex) (newContext:ParserContext) =
    let ProcessLocalAttributes vert atts = ProcessLocalAttributes pcontext vert atts
    let AddPostProcess name vert = pcontext.PostProcess.Add( (fun() ->
        let parent = pcontext.Context.NoFailLookup name
        pcontext.Graph.Edges.Extend parent vert |> ignore ))
        
    let content,name,atts,particle,ann = 
        match content with
            | :? XmlSchemaSimpleContent as simple -> 
                match simple.Content with
                    | :? XmlSchemaSimpleContentExtension as extension ->
                        let simpleContent = pcontext.Graph.Vertexes.CreateComplexSimpleExtension()
                        (simpleContent :?> IVertex),extension.BaseTypeName.Name,extension.Attributes,None,box extension
                    | :? XmlSchemaSimpleContentRestriction as restriction ->
                        let simpleContent = pcontext.Graph.Vertexes.CreateComplexSimpleRestriction()
                        (simpleContent :?> IVertex),restriction.BaseTypeName.Name,restriction.Attributes,None,box restriction
                    | _ -> raise (new System.InvalidOperationException "Odd simple content model")
            | :? XmlSchemaComplexContent as complex -> 
                match complex.Content with
                    | :? XmlSchemaComplexContentExtension as extension ->
                        let complexContent = pcontext.Graph.Vertexes.CreateComplexComplexExtension()
                        (complexContent :?> IVertex),extension.BaseTypeName.Name,extension.Attributes,(Some extension.Particle), box extension
                    | :? XmlSchemaComplexContentRestriction as restriction ->
                        let complexContent = pcontext.Graph.Vertexes.CreateComplexComplexRestriction()
                        (complexContent :?> IVertex),restriction.BaseTypeName.Name,restriction.Attributes,(Some restriction.Particle), box restriction
                    | _ -> raise (new System.InvalidOperationException "Odd complex content model")
            | _ -> raise (new System.InvalidOperationException( "Unknown content model" ))
    
    ProcessLocalAttributes content atts
    ProcessAnnotationType pcontext.Graph content ann
    match particle with
        | Some part -> ProcessComplexParticle pcontext content part
        | None -> ()
    AddPostProcess name content
    
and ProcessComplexElem (pcontext:ParserContext) (elem:XmlSchemaComplexType) name =
    let vertex = CreateComplexVertex pcontext.Graph pcontext.Context name
    ProcessAnnotationType pcontext.Graph (vertex :?> IVertex) (box elem)
    let newPContext = { pcontext with Context = new BuilderContext(Some pcontext.Context) }
    if elem.ContentModel <> null 
        then //Content models are basically different ways of deriving
            ProcessComplexElemContentModel pcontext elem.ContentModel vertex newPContext
        else //No derivations, take care of the attributes and the sequence/choice/all
            ProcessLocalAttributes pcontext (vertex :?> IVertex) elem.Attributes
            if elem.Particle <> null then ProcessComplexParticle pcontext (vertex :?> IVertex) elem.Particle
            
and ProcessComplexParticle (pcontext:ParserContext) vertex (inParticle:XmlSchemaParticle) =
    let createMinMaxValue item (itemS:string) =
        if itemS = null || itemS.Length = 0 || itemS <> "unbounded" then MinMaxNum(item) else SpecialValue(EMinMaxValues.Unbounded)
    let minValue = createMinMaxValue inParticle.MinOccurs inParticle.MinOccursString
    let maxValue = createMinMaxValue inParticle.MaxOccurs inParticle.MaxOccursString  
    let particle,children,ann = 
        match inParticle with
            | :? XmlSchemaSequence as seq -> 
                (pcontext.Graph.Vertexes.CreateSequence minValue maxValue :> IParticle),Some seq.Items,true
            | :? XmlSchemaChoice as choice -> 
                (pcontext.Graph.Vertexes.CreateChoice minValue maxValue :> IParticle),Some choice.Items,true
            | :? XmlSchemaElement as elem -> 
                let retval = (pcontext.Graph.Vertexes.CreateParticleElement minValue maxValue :> IParticle)
                let mutable addDoc = true
                if elem.RefName = null 
                    then 
                        let newVert = CreateComplexVertex pcontext.Graph pcontext.Context elem.Name
                        ProcessAnnotationType pcontext.Graph (newVert :?> IVertex) (box inParticle)
                        let newContext = { pcontext with Context = new BuilderContext(Some pcontext.Context) }
                        ProcessElemContent newContext elem
                        addDoc <- false
                        pcontext.Graph.Edges.Reference (retval :?> IVertex) (newVert :?> IDatatypeVertex) |> ignore
                    else 
                        if elem.Name = null || elem.Name.Length = 0
                            then
                                pcontext.PostProcess.Add( (fun()->
                                    pcontext.Graph.Edges.Reference (retval :?> IVertex) (pcontext.Context.NoFailLookup elem.RefName.Name ) |> ignore ) )
                            else
                                pcontext.PostProcess.Add( (fun()->
                                    pcontext.Graph.Edges.NamedReference elem.Name (retval :?> IVertex) (pcontext.Context.NoFailLookup elem.RefName.Name) |> ignore ) )
                (pcontext.Graph.Vertexes.CreateParticleElement minValue maxValue :> IParticle),None,addDoc
            | :? XmlSchemaGroupRef as gref ->
                let retval = (pcontext.Graph.Vertexes.CreateGroupRef minValue maxValue :> IParticle)
                pcontext.PostProcess.Add( (fun()->
                    pcontext.Graph.Edges.Reference (retval :?> IVertex) (pcontext.Context.NoFailLookup gref.RefName.Name) |> ignore ))
                retval,None,true
            | :? XmlSchemaAny as any -> 
                (pcontext.Graph.Vertexes.CreateAny minValue maxValue :> IParticle),None,true
            | _ -> raise (new InvalidOperationException (sprintf "Unrecognized particle type %s" (inParticle.GetType()).Name ))
    
    ProcessAnnotationType pcontext.Graph (particle :?> IVertex) (box inParticle)      
    if ann then pcontext.Graph.Edges.Particle vertex particle |> ignore

and ProcessElemContent (pcontext:ParserContext) (elem:XmlSchemaElement) =
    match elem.SchemaType with
        | :? XmlSchemaComplexType as schemaType -> ProcessComplexElem pcontext schemaType elem.Name
        | _ -> raise (new InvalidOperationException (sprintf "unhandled element schema type: %s" (elem.SchemaType.GetType()).Name ) )
                  
let ProcessTopLevelElement (pcontext:ParserContext) (elem:XmlSchemaElement) =
    let refName = RefNameAccess elem
    match refName with
        //Add a post-process method to lookup and add the derived class
        //to whatever class is returned.  If a class is returned.
        | Some str -> raise (new System.InvalidOperationException( "Top level elements should not have ref" ) )
        | None -> ()
    ProcessElemContent pcontext elem
    
let ProcessTopLevelSimple (pcontext:ParserContext) elem =
    ()
    
let ProcessTopLevelComplex (pcontext:ParserContext) elem =
    ()
    
let ProcessTopLevelGroup (pcontext:ParserContext) elem =
    ()
    
let BuildGraph graph (schema:XmlSchema) =
    let rootContext = new BuilderContext()
    BuildBasicTypes graph rootContext
    let pcontext = { Graph = graph; Context = rootContext; PostProcess = new List<(unit->unit)>() }
    for item in schema.Items do
        match item with
            | :? XmlSchemaAnnotation as ann -> 
                let doc = ProcessAnnotation (Some ann)
                match doc with
                    | Some str -> graph.Vertexes.CreateDocumentationVertex(str) |> ignore
                    | None -> System.Console.WriteLine( "Didn't find documentation" )
            | :? XmlSchemaElement as elem -> ProcessTopLevelElement pcontext elem
            | :? XmlSchemaSimpleType as elem -> ProcessTopLevelSimple pcontext elem
            | :? XmlSchemaComplexType as elem -> ProcessTopLevelComplex pcontext elem
            | :? XmlSchemaGroup as elem -> ProcessTopLevelGroup pcontext elem
            | _ -> 
                let name = (item.GetType()).Name
                let message = sprintf "obj type: %s" (item.GetType()).Name
                System.Console.WriteLine message
                
      